home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Pocket 6.3 / Pocket DA / DA Source / dDict.txt next >
Text File  |  1993-06-25  |  44KB  |  1,833 lines
  1. ; this file is: Common.txt  --  forth words
  2. ; Tue Apr 05, 1988 21:59:10 load files >32K
  3. ; Thu Apr 07, 1988 15:59:46 nested loads
  4. ; Tue Apr 19, 1988 05:05:37 change "?button"
  5. ; Mon Apr 25, 1988 15:10:19 implement macros
  6. ; Tue Apr 26, 1988 19:49:49 optomizing "back"
  7. ; Thu Apr 28, 1988 23:09:23 fix id.  better constant,2constant  add zero
  8. ; Fri Apr 29, 1988 09:43:49 add dliteral
  9. ; Sun May 01, 1988 04:24:52 make variable a macro
  10. ; Thu May 12, 1988 11:41:08 remove (pdo)  add 1- 2- & sp@  use slashFail
  11. ; Sun May 29, 1988 20:16:39 make create shorter
  12. ; Tue May 31, 1988 14:27:25 make +md a 4 byte macro  remove 2-
  13. ; Tue Jun 07, 1988 11:39:00 add r0@, s0@, rp@  redo stod
  14. ; Sun Jun 23, 1991 09:33:00 add open
  15. ; Thu Jan 13, 1992 19:05:00 Floating point math (rewrite 13Apr)
  16. ; Sun Feb 02, 1992 00:02:00 fix back
  17. ; Wed Apr 01, 1992 00:12:00 change stkchk
  18. ; Tue Apr 14, 1992 22:48:00 rearrange to bring essentials toward front
  19. ; Sun Apr 19, 1992 23:24:00 split open into 2 parts, add: ae: ;ae> ?gestalt
  20. ; Sat Aug 08, 1992 18:53:00 remove ae: ;ae> bye  revert stkchk open  --> grow 
  21. ; Sat Jan 23, 1993 21:43:00 fix type and froll
  22. ; Fri May 28, 1993 22:50:00 move ?BUTTON and FLITERAL, fix +LOOP and QUIT
  23.  
  24. ; ----- the dictionary ------
  25.  
  26. DictStart:
  27.     DC.L    0            ; End of dictionary search
  28.     
  29.     DC.B    128+1,13,0,0        ; "{cr}" ( -- )
  30.     DC.W    DictStart-base
  31. CRet:    JSR    pasting-base(BP)    ; interpret from the scrap
  32.     TST.B    fint-base(BP)
  33.     BEQ.S    @0
  34.     MOVE.B    #0,0(IS,D5)        ; replace CR with null
  35.     @0:    JMP    Main
  36.     
  37.     DC.B    129,0,0,0        ; "{null}" ( -- )
  38.     DC.W    cret-theLink        ; interpret from the keyboard
  39. NRet:    JSR    clearTermBuf-base(BP)
  40.     CLR.L    Counter            ; clear input buffer offset
  41.     TST.B    fcolon-base(BP)
  42.     BNE.S    @0            ; don't issue prompt if compiling
  43.     JSR    prompt-base(BP)
  44.     @0:    JMP    kdone-base(BP)        ; jump back to the application
  45.  
  46.     DC.B    128+1,'\',0,0        ; "\" ( -- ) backslash
  47.     DC.W    nret-theLink        ;  line ending comment
  48. Backsl:    bra.s    cret
  49.  
  50.     DC.B    9,'?TE'            ; "?terminal" ( -- flag )
  51.     DC.W    backsl -theLink        ;  was a key pressed?
  52. qTerm:    JMP    qtcode-base(BP)
  53.  
  54.     DC.B    3,'KEY'            ; "key" ( -- ascii )
  55.     DC.W    qterm-theLink        ;   wait for a key press
  56. Key:    JMP    keycode-base(BP)
  57.  
  58.     DC.B    6,'?ST'            ; "?stack" ( ? -- )
  59.     DC.W    key-theLink
  60. StkChk:    CMPA.L    UFlow-base(BP),PS
  61.     BPL.S    @0
  62.     RTS
  63.     @0:    JSR    space-base(BP)
  64.       MOVEQ    #42,D0            ; print *  if stack underflow
  65.     JSR    EmitCode-base(BP)
  66.     BRA.S    huh
  67.  
  68.     DC.B    7,'?BU'            ; "?button" ( -- flag )
  69.     DC.W    StkChk-theLink
  70. QButton:
  71.     CLR    -(SP)
  72.     _Button
  73.     MOVE    (SP)+,-(PS)
  74.     BEQ.S    @0
  75.     SUBI    #257,(PS)
  76.     @0:    RTS
  77.  
  78.     DC.B    6,'WHA'            ; "whazat" ( -- )
  79.     DC.W    QButton-theLink
  80. WhaZat:    JSR    dwrd-base(bp)
  81.     BRA.S    huh
  82.     
  83.     DC.B    5,'ABO'            ; "abort" ( -- )
  84.     DC.W    whazat-theLink
  85. huh:    MOVE.L    Szero-base(BP),PS
  86.     MOVEQ    #63,D0            ; send ?  means not found in dict
  87.     JSR    EmitCode-base(BP)
  88.     bsr.s    crlf
  89.     BRA.S    fin
  90.     
  91.     DC.B    4,'QUI'            ; "quit" ( -- )
  92.     DC.W    huh-theLink        ;    clear stacks and restart
  93. fin:    JSR    emptyfs-base(BP)    ; clear pending loads
  94.     CLR.L    fcolon-base(BP)        ; initialize flags
  95.     BSET.B    #7,fint-base(BP)
  96.     JMP    nret-base(BP)
  97.  
  98.     DC.B    2,'CR',0        ; "cr" ( -- ) output CR to screen
  99.     DC.W    fin-theLink
  100. CRLF:    JMP    doCR-Base(BP)
  101.  
  102.     DC.B    3,'.OK'            ; ".ok" ( -- )
  103.     DC.W    crlf-theLink
  104. Prompt:    JSR    space-base(BP)        ; send space
  105.     MOVEQ    #111,D0
  106.     JSR    EmitCode-base(BP)    ; send "o"
  107.     MOVEQ    #107,D0
  108.     JSR    EmitCode-base(BP)    ; send "k"
  109.     JMP    space-base(BP)        ; send another space & return
  110.  
  111.     DC.B    5,'UPP'            ; "upper" ( addr -- )
  112.     DC.W    prompt-theLink        ;   change a string to upper case
  113. Upper:    MOVE    (PS)+,D0
  114.     LEA    0(BP,D0.W),A0        ; get the address
  115.     CLR    D0
  116.     MOVE.B    (A0),D0            ; get count
  117.     @0:    CMPI.B    #$60,0(A0,D0.W)        ; BEGIN  get char at addr + count
  118.     BLE.S    @1            ;   char > 'a'
  119.     CMPI.B    #$7B,0(A0,D0.W)        ;   char < 'z'
  120.     BGE.S    @1            ;   AND IF
  121.     SUBI.B    #32,0(A0,D0.W)        ;     char 32 - -> char THEN
  122.     @1:    DBRA    D0,@0            ; count 1- -> count count NOT UNTIL
  123.     RTS
  124.  
  125.     DC.B    5,'TOK'            ; "token" ( -- ) put a token
  126.     DC.W    upper-theLink        ;   from (IS) into (DP),
  127. Token:    MOVE    #32,-(PS)        ;   which is at end of dict.
  128.     BSR.S    word
  129.     JSR    here-base(BP)        ; Fri Apr 29, 1988 00:27:23 simpl
  130.     BRA.S    Upper
  131.  
  132.     DC.B    6,'HEA'            ; "header" ( -- ) create a header
  133.     DC.W    token-theLink        ;   for the current word at DP
  134. Header:    MOVE    Dict,4(DP)        ; link header to dictionary
  135.     MOVE.L    DP,Dict            ; update DICT
  136.     SUB.L    BP,Dict            ; make it a rel.addr
  137.     addq.l    #6,dp            ; update DP    ; (was) LEA 6(DP),DP
  138.     RTS
  139.  
  140.     DC.B    4,'WOR'            ; "word" ( c -- ) c is delimiter
  141.     DC.W    header-theLink        ;   get chars from (IS) into HERE
  142. Word:    MOVE.L    D4,-(SP)        ; preserve the register
  143.     MOVE    (PS)+,D4        ; get delimiter character
  144.     CLR.L    (DP)            ; clear token buffer
  145.     CLR.L    D1            ; clear count
  146.     @0:    MOVE.B    (IS)+,D0        ; get characters until delimiter
  147.     CMP.B    D4,D0
  148.     BEQ.S    @1
  149.     MOVE.B    D0,1(DP,D1)        ; place in token buffer
  150.     ADDQ.B    #1,D1            ; increment count
  151.     BRA.S    @0
  152.     @1:    MOVE.B    D1,(DP)            ; put count in 1st byte of buffer
  153.     BEQ.S    @0            ; if count is 0 repeat
  154.     MOVE.L    (SP)+,D4        ; restore the register
  155.     RTS
  156.  
  157.     DC.B    1,'''',0,0        ; "'" ( -- rel.addr ) return the
  158.     DC.W    word-theLink        ;  cfa of the following word
  159. Tick:    bsr.s    token            ; get the next word
  160.     MOVE    Dict,-(PS)        ; push dict ptr to parmstk
  161.     bsr.s    search            ; lookup the current token
  162.     TST    (PS)+
  163.     BEQ    Whazat
  164.     RTS
  165.  
  166.     DC.B    6,'SEA'            ; "search" ( addr -- cfa t  OR  f )
  167.     DC.W    tick-theLink
  168. Search:    MOVE.L    (DP),D1            ; put token "stem" in D1
  169.     MOVE    (PS),D0            ; use A0 as search pointer
  170.     CLR    fmacro-base(BP)        ; clear the macro flag
  171.     @0:    LEA    0(BP,D0.W),A0        ; DO
  172.     TST    (A0)            ;   IF DictStart  exit NOFIND
  173.     BEQ.S    nofind
  174.     CMP.L    (A0),D1            ;   compare word to candidate
  175.     BEQ.S    find            ;   IF found, exit FIND
  176.     BCHG    #31,D1            ;   set immediate bit
  177.     CMP.L    (A0),D1            ;   compare to "immediate" version
  178.     BEQ.S    ifind            ;   IF found, exit FINDIMM
  179.     BCHG    #31,D1            ;   reset immediate bit
  180.     BCHG    #30,D1            ;   set macro bit
  181.     CMP.L    (A0),D1            ;   compare to "immediate" version
  182.     BEQ.S    mfind            ;   IF found, exit FINDIMM
  183.     BCHG    #30,D1            ;   reset macro bit
  184.     MOVE    4(A0),D0        ;   get link rel.address
  185.     BRA.S    @0            ; LOOP
  186. nofind:    CLR    (PS)            ; push fail flag
  187.     RTS
  188.  mfind:    BSET.B    #7,fmacro-base(BP)    ; set macro flag
  189.     BRA.S    find
  190.  ifind:    BSET.B    #7,fimmed-base(BP)    ; set immediate flag
  191.   find:    LEA    6(A0),A0        ; cfa is at 6+nfa
  192.     SUBA.L    BP,A0            ; convert code address to relative
  193.     MOVE    A0,(PS)            ; push code rel address
  194.     MOVE    #-1,-(PS)        ; push success flag
  195.     RTS
  196.  
  197.     DC.B    6,'NUM'            ; "number" ( addr -- n t  OR  f )
  198.     DC.W    search-theLink
  199. Number:    MOVE.L    D4,-(SP)        ; save the register
  200.     CLR.L    D1
  201.     CLR.L    D4            ; clear conversion register
  202.     MOVE    (PS)+,D0        ; get token addr in D0
  203.     LEA    0(BP,D0.W),A0        ; put abs.addr in A0
  204.     CMPI.B    #'-',1(A0)        ; is it negative?
  205.     BNE.S    @0            ; IF yes
  206.     BSET.B    #7,fneg-base(BP)    ;     set negative flag
  207.     MOVE.B    #'0',1(A0)        ;     change dash to zero
  208.     @0:    CLR.L    D0            ; THEN
  209.     MOVE.B    (A0)+,D1        ; get digit count
  210.  digit:    MOVE.B    (A0)+,D0        ; BEGIN get next digit
  211.     SUBI.B    #48,D0            ;     strip ASCII prefix
  212.     BLT.S    @2            ;     if digit too small, FAIL
  213.     CMP    #10,D0            ;     if digit > 9
  214.     BLT.S    @1            ;     adjust for radix>10 values
  215.     SUBI.B    #7,D0            ;     and test again
  216.     CMP    #10,D0
  217.     BLT.S    @2
  218.     @1:    CMP    NBase-base(BP),D0    ;     if base < digit
  219.     BGE.S    @2            ;     FAIL
  220.     MULU    NBase-base(BP),D4    ;     multiply value by base
  221.     ADD    D0,D4            ;     add current digit
  222.     SUBQ.B    #1,D1            ;     decrement count
  223.     BNE.S    digit            ; UNTIL no digits remain
  224.         BCLR    #7,fneg-base(BP)    ; test and clear negative flag
  225.     BEQ.S    @0            ; if set
  226.     NEG    D4            ; Negate it
  227.     @0:    MOVE    D4,-(PS)        ; push number
  228.     MOVE    #-1,-(PS)        ; push success flag
  229.     BRA.S    @3
  230.     @2:    CLR    -(PS)            ; push fail flag
  231.     @3:    MOVE.L    (SP)+,D4        ; restore the register
  232.     RTS
  233.  
  234.     DC.B    7,'FNU'            ; FNUMBER ( dabs.addr -- f )
  235.     DC.W    number-theLink        ; convert string at dabs.addr to fp
  236. fnum:    MOVE.L    (PS)+,-(RS)
  237.     MOVE    #1,-(PS)
  238.     PEA    (PS)
  239.     PEA    $14(DP)
  240.     CLR    -(PS)
  241.     PEA    (PS)
  242.     FPSTR2DEC
  243.     ADDQ.L    #4,PS
  244.     CMPI    #$054E,24(DP)        ; check for NAN##
  245.     BNE.S    @0
  246.     JMP    whazat-base(BP)
  247.     @0:    PEA    $14(DP)
  248.     SUBQ.L    #6,PS
  249.     SUBQ.L    #4,PS
  250.     PEA    (PS)
  251.     FDEC2X
  252.     RTS
  253.     
  254.     DC.B    7,'EXE'            ; "execute" ( cfa -- ) do a routine
  255.     DC.W    fnum-theLink        ;    whose cfa is on the stack
  256. EXECUTE    MOVE    (PS)+,D0        ; pop code address
  257.     JMP    0(BP,D0.W)        ; execute & return
  258.  
  259.     DC.B    8,'MCO'            ; "mcompile" ( cfa -- ) 
  260.     DC.W    Execute-theLink        ; compile subroutine bodies inline 
  261. MComp:    MOVE    (PS)+,D0
  262.     LEA    0(BP,D0.W),A0        ; addr of word
  263.     @0:    MOVE    (A0)+,D0
  264.     CMPI    #$4E75,D0        ; if its an RTS your done
  265.     BEQ.S    @1
  266.     MOVE    D0,(A2)+        ; if not, compile it
  267.     BRA.S    @0            ; do next word
  268.     @1:    RTS
  269.     
  270.     DC.B    128+9,'[CO'        ; "[compile]" ( -- )  compile
  271.     DC.W    mcomp-theLink        ;   the next immediate word
  272. bCompile:
  273.     JSR    tick-base(BP)        ; get the cfa of the next word
  274.     bra.s    compile            ;  and compile a JSR to it
  275.     
  276.     DC.B    7,'COM'            ; "compile" ( cfa -- ) compile a 
  277.     DC.W    bcompile-theLink        ;    call to the cfa on the stack
  278. COMPILE    MOVE    #$04EAB,(DP)+        ; compile "JSR d(A3)"
  279.     BRA.S    Comma            ; compile displacement value
  280.  
  281.     DC.B    9,'IMM'            ; "immediate" ( -- ) make the last
  282.     DC.W    compile-theLink        ;   word defined immediate
  283. IMMED    BSET    #7,0(BP,Dict.W)        ; set immediate bit of most recent word
  284.     RTS
  285.  
  286.     DC.B    5,'MAC'            ; "macro" ( -- ) make the last
  287.     DC.W    immed-theLink        ;   word defined an inline macro
  288. marco:    BSET    #6,0(BP,Dict.W)        ; set macro bit of most recent word
  289.     RTS
  290.  
  291.     DC.B    1,':',0,0        ; ":" ( -- ) make a header for a 
  292.     DC.W    marco-theLink        ;   word definition
  293. COLON    JSR    token-Base(BP)        ; make header
  294.     JSR    header-base(BP)
  295.     BRA.S    rbrack            ; enter compile mode
  296.     
  297.     DC.B    129,']',0,0        ; "]" ( -- ) enter compile mode
  298.     DC.W    colon-theLink
  299. rBrack:    BSET    #7,fcolon-base(BP)    ; set colon flag
  300.     RTS
  301.  
  302.     DC.B    129,';',0,0        ; ";" ( -- ) end a word definition
  303.     DC.W    rBrack-theLink
  304. SEMI    MOVE    #$4E75,(DP)+        ; compile "RTS"
  305.     BRA.S    lbrack
  306.     
  307.     DC.B    129,'[',0,0        ; "[" ( -- ) leave compile mode
  308.     DC.W    semi-theLink
  309. lBrack:    CLR.B    fcolon-base(BP)        ; clear colon flag
  310.     RTS
  311.     
  312.     DC.B    7,'LIT'            ; "literal" compiling: ( n -- )
  313.     DC.W    lBrack-theLink        ;   executing: ( -- n )
  314. LITERAL    MOVE    #$03D3C,(DP)+        ; compile move #xxxx,-(PS)
  315.     BRA.S    Comma            ; compile constant
  316.  
  317.     DC.B    64+1,',',0,0        ; "," ( n -- )
  318.     DC.W    literal-theLink
  319. COMMA    MOVE    (PS)+,(DP)+        ; pop number to dictionary
  320.     RTS
  321.  
  322.     DC.B    8,'FLI'        ; FLITERAL ( comp: n5 n4 n3 n2 n1 -- |exec: -- n5 n4 n3 n2 n1 )
  323.     DC.W    comma-theLink
  324. flit:    MOVE    (PS),D0
  325.     MOVE    2(PS),D1
  326.     MOVE    8(PS),(PS)
  327.     MOVE    6(PS),2(PS)
  328.     MOVE    D0,8(PS)
  329.     MOVE    D1,6(PS)
  330.     MOVEQ    #4,D0
  331.     @0:    bsr.s    literal
  332.     DBRA    D0,@0
  333.     RTS
  334.  
  335.     DC.B    128+2,',$',0        ; ",$" ( -- )
  336.     DC.W    flit-theLink        ; compile a hex number from input
  337. CommaH:    MOVE    NBase-base(BP),-(RS)
  338.     MOVE    #$10,nbase-base(BP)
  339.     JSR    token-base(BP)
  340.     BSR.S    here
  341.     JSR    number-base(BP)
  342.     MOVE    (RS)+,nbase-base(BP)
  343.     TST    (PS)+
  344.     BEQ    whazat
  345.     BRA.S    comma
  346.  
  347.     DC.B    4,'HER'            ; "here" ( -- addr )
  348.     DC.W    commah-theLink        ;   rel.addr of compile point
  349. here:     MOVE.L    DP,-(PS)
  350.     BRA.S    torel
  351.  
  352.     DC.B    8,'DLI'            ; "dliteral" compiling: ( d -- )
  353.     DC.W    here-theLink        ;   executing: ( -- d )
  354. DLit:    MOVE    #$2D3C,(DP)+        ; compile move.l #xxxx,-(PS)
  355.     MOVE.L    (PS)+,(DP)+        ; compile double number
  356.     RTS
  357.  
  358.     DC.B    4,'>RE'            ; ">rel" (to-rel) ( rel.uu) (rel.ah)
  359.     DC.W    dlit-theLink        ; ( daddr32 -- addr16 )
  360. toRel:    MOVE.L    (PS)+,D0        ; get the Daddr32 from stack
  361.     SUB.L    BP,D0            ; get difference from base addr
  362.     MOVE    D0,-(PS)        ; push the 16 bit part of it
  363.     RTS
  364.  
  365.     DC.B    5,'COU'            ; "count" ( addr -- addr+1 length )
  366.     DC.W    torel-theLink
  367. Count:    CLR    D1
  368.     MOVE    (PS),D0
  369.     MOVE.B    0(BP,D0.W),D1
  370.     ADDQ    #1,(PS)
  371.     MOVE    D1,-(PS)
  372.     RTS
  373.  
  374.     DC.B    64+3,'+MD'        ; "+MD" ( offset -- addr )
  375.     DC.W    count-theLink
  376. MacDat:    ADDI    #theWindow-base,(PS)    ; add data addr to stacked offset
  377.     RTS
  378.     
  379.     DC.B    4,'PAG'            ; "page" ( -- )
  380.     DC.W    macdat-theLink        ; clear the window
  381. Page:    PEA    WContRect-base(BP)    ; The visable part of the window.
  382.     _EraseRect
  383.     MOVE.l    #$90001,-(SP)
  384.     _MoveTo                ; set pen position to home (1,9)
  385.     _PenNormal            ; 1X1, black, patcopy
  386.     MOVE.l    #$40000,-(SP)
  387.     _TextFont            ; Monaco
  388.     _TextFace            ; plain text
  389.     MOVE.l    #$90000,-(SP)
  390.     _TextSize            ; 9 point
  391.     _TextMode            ; srcCopy
  392.     RTS
  393.  
  394.     DC.B    4,'BEE'            ; "beep" ( -- )
  395.     DC.W    page-theLink
  396. Beep:    MOVE.W    #3,-(SP)
  397.     _SysBeep
  398.     RTS
  399.  
  400.     DC.B    64+3,'MON'        ; "mon" ( -- ) execute _Debugger
  401.     DC.W    beep-theLink
  402. Mon:    _DeBugger
  403.     RTS
  404.  
  405. TexD:    DC.W    'TEXT'
  406.  
  407.     DC.B    4,'OPE'        ; "open" ( -- )
  408.     DC.W    mon-theLink
  409. Open:    MOVE.L    #$4B0037,-(SP)        ; point: 75,55
  410.     CLR.L    -(SP)            ; no prompt
  411.     CLR.L    -(SP)            ; no filter
  412.     MOVE    #1,-(SP)        ; 1 type
  413.     PEA    texd-base(BP)
  414.     CLR.L    -(SP)            ; no hook
  415.     PEA    (A2)            ; put sfreply at here
  416.     MOVE    #2,-(SP)
  417.     _Pack3
  418.     TST    (A2)            ; check 'good' field
  419.     BEQ.S    beep            ; beep if cancel
  420.  
  421.     MOVE    6(A2),-(PS)        ; hold the vrefnum on stack
  422.     CLR    D0
  423.     @0:    MOVE.L    10(A2,D0.W),0(A2,D0.W)    ; move the file name to 'here'
  424.     ADDQ    #4,D0
  425.     CMP    #32,D0
  426.     BLE.S    @0
  427.     BRA.S    load1
  428.     
  429.     DC.B    3,'-->'            ; "-->" ( -- )
  430.     DC.W    open-theLink
  431. Load:    JSR    token-base(BP)        ; put filename string at here
  432.     CLR    -(PS)            ; set vrefnum to 0 (path is specified)
  433.  load1:    MOVE    fsptr-base(BP),D0    ; get file stack pointer
  434.     BMI    @0            ;  ... save the offset into text ...
  435.     LEA    fofsets-base(BP),A0    ;  ... at fofsets+fspointer
  436.     MOVE.L    TextO-base(BP),0(A0,D0)
  437.     LEA    fends-base(BP),A0    ;  TextE at fends+fspointer
  438.     MOVE.L    TextE-base(BP),0(A0,D0)
  439.     @0:    ADDQ    #4,fsptr-base(BP)    ; increment the file stack pointer
  440.     
  441.     MOVE.L    #80,D0            ; create an 80 byte block for
  442.     DC.W    $A31E    ; _NewPtr ,CLEAR - the file control buffer
  443.     MOVE.L    A0,A4            ; save it for later
  444.     MOVE.B    #1,27(A0)        ; set read only permission
  445.     MOVE.L    DP,18(A0)        ; set name pointer
  446.     MOVE    (PS)+,22(A0)        ; set vrefnum (working directory)
  447.     DC.W    $A100    ; _HOpen the file
  448.     TST    16(A0)
  449.     BNE.S    derror
  450.     _GetEOF                ; get ...
  451.     MOVE.L    28(A0),36(A0)        ;  ... and set ...
  452.     MOVE.L    28(A0),-(PS)        ;  ... and hold the file size
  453.     
  454.     MOVE.L    (PS),D0            ; set block size = file size
  455.     _NewHandle
  456.     BMI.S    derror
  457.     
  458.     MOVE    fsptr-base(BP),D0    ; get file stack pointer
  459.     LEA    fstack-base(BP),A1    ; file stack address
  460.     MOVE.L    A0,0(A1,D0.W)        ; stash the handle at fstack+(fsptr)
  461.     _HLock
  462.     
  463.     MOVE.L    (A0),A0            ; get start addr of block
  464.     MOVE.L    A0,TextO-base(BP)    ; set buffer start
  465.     MOVE.L    A0,D0            ; set buffer end ...
  466.     ADD.L    (PS)+,D0
  467.     MOVE.L    D0,TextE-base(BP)    ;  ... to start + size
  468.     
  469.     MOVE.L    A4,A0
  470.     MOVE.L    TextO-base(BP),32(A0)    ; set read buffer addr in fcb
  471.     _Read                ; read data from file ...
  472.     TST    16(A0)            ; ... to scrap buffer
  473.     BNE    derror
  474.     _Close
  475.     _DisposPtr
  476.     JMP    go-base(BP)        ; interpret scrap buffer
  477.  
  478. DError:    MOVE    16(A0),-(PS)
  479.     _Close
  480.     _DisposPtr
  481.     JSR    pquote-base(BP)
  482.     DC.B    10,'I/O Error:',0    ; print the error messsage
  483.     JSR    dot-base(BP)        ; report the error number
  484.     JMP    huh-base(BP)
  485.  
  486.     DC.B    8,'?GE'        ; "?GESTALT"
  487.     DC.W    load-theLink    ; ( d.selector -- d.response true or false )
  488. QGestalt:        ; false if 64K ROM or no _Gestalt or bad selector
  489.     ; check for 64K ROM
  490.     MOVE    #$A86E,D0        ; _InitGraf
  491.     _GetTrapAddress.newTool
  492.     MOVE.L    A0,D1
  493.     MOVE    #$AA6E,D0        ; _InitGraf AND $200
  494.     _GetTrapAddress.newTool
  495.     CMP.L    A0,D1
  496.     BEQ.S    gser1            ; 64KROM
  497.  
  498.     ; Check for gestalt
  499.     MOVE.W    #$A89F,D0        ; _Unimplemented
  500.     _GetTrapAddress.newTool        ; NGetTrapAddress
  501.     MOVE.L    A0,D1
  502.     MOVE.W    #$A1AD,D0        ; _Gestalt
  503.     _GetTrapAddress.newOS        ; NGetTrapAddress
  504.     CMP.L    A0,D1
  505.     BEQ.S    gser1            ; no gestalt
  506.  
  507.     ; run gestalt
  508.     MOVE.L    (PS)+,D0
  509.     _Gestalt
  510.     BNE.S    gser2
  511.     MOVE.L    A0,-(PS)        ; return the result  ... and ...
  512.     MOVE    #-1,-(PS)        ; return true
  513.  gsret:    RTS
  514.  
  515.  gser1:    ADDQ.L    #4,PS            ; gestalt error
  516.  gser2:    CLR    -(PS)            ; return false
  517.     RTS
  518.  
  519.     DC.B    128+2,',S',0        ; ",S" compile a dnumber from ascii
  520.     DC.W    qgestalt-theLink    ; NOTE: 1 and only 1 space seperates
  521. CommaS:    ;    move.l    (is)+,-(ps)    ; this word from its data.
  522.     MOVE.L    A2,A0
  523.     MOVEQ    #4,D0
  524.     @0:    MOVE.B    (IS)+,(A0)+
  525.     DBRA    D0,@0
  526.     MOVE.L    (A2),-(PS)
  527.  
  528.     TST.B    fcolon-base(BP)
  529.     BEQ.S    gsret
  530.     JMP    dlit-base(BP)
  531.  
  532.     DC.B    64+9,'INT'        ; "interpret" ( -- )
  533.     DC.W    commas-theLink
  534. Interp:    JMP    main-base(BP)
  535.     RTS
  536.  
  537.     
  538. GRet:    LEA    Bottom,BP        ; reset the base pointer
  539.       LEA    0(BP,D1.W),DP        ; abs.addr into register
  540.     LEA    0(BP,D2.W),IS
  541.     JSR    toabs-base(BP)
  542.     MOVE.L    (PS)+,(RS)
  543.     RTS
  544.  
  545.     DC.B    4,'GRO'            ; "grow" ( bytes -- )
  546.     DC.W    interp-theLink        ; enlarge the dictionary headroom
  547. Grow:    JSR    here-base(BP)
  548.     MOVE    (PS)+,D1        ; hold rel DP in D1
  549.     MOVE.L    IS,-(PS)
  550.     JSR    torel-base(BP)
  551.     MOVE    (PS)+,D2
  552.     MOVE.L    (RS),-(PS)
  553.     JSR    torel-base(BP)
  554.     JSR    swapp-base(BP)
  555.     MOVEA.L    expand-base(BP),A0
  556.     JMP    (A0)            ; JSR won't return here
  557.  
  558.     DC.B    4,'ROO'            ; "room" ( -- bytes )
  559.     DC.W    grow-theLink
  560. Room:    LEA    Bottom,A0        ; version 3+ use (PC) addressing
  561.     _RecoverHandle            ; use handle rather than pointer
  562.     _GetHandleSize
  563.     LEA    Bottom,A0        ; Bottom ... version 3+ use (PC) addressing
  564.     ADDA.L    D0,A0            ;  +  block size ...
  565.     SUBA.L    A2,A0            ;  -  end of dictionary
  566.     MOVE    A0,-(PS)        ;  =  unused dictionary space
  567.     RTS
  568.  
  569.     
  570.     DC.B    4,'SAV'            ; "save" ( -- ) save the dictionary
  571.     DC.W    room-theLink
  572. Save:    JSR    here-base(BP)
  573.     MOVE    (PS)+,freePt-base(BP)    ; save current DP
  574.     MOVE    Dict,DictPt-base(BP)    ; save current DictPt
  575.     BSR.S    room
  576.     MOVE    (PS),freesz-base(BP)    ; save current headroom
  577.     JSR    negate-base(BP)
  578.     BSR.S    grow            ; reduce headroom to 4 bytes
  579.     LEA    Bottom,A0        ; version 3+ use (PC) addressing
  580.     _RecoverHandle            ; get DICT's handle
  581.     CLR    -(SP)
  582.     MOVE.L    A0,-(SP)        ; push 2, 1 for each operation
  583.     MOVE.L    A0,-(SP)
  584.     _ChangedResource
  585.     _HomeResFile
  586.     _UpdateResFile            ; write out the DICT
  587.     MOVE    freesz-base(BP),-(PS)
  588.     BRA.S    grow            ; restore headroom
  589.  
  590.     DC.B    4,'>AB'            ; ">abs" (to-abs)
  591.     DC.W    save-theLink        ; ( addr16 -- daddr32 )
  592. toAbs:    CLR.L    D0
  593.     MOVE    (PS)+,D0        ; pop rel addr
  594.     LEA    0(BP,D0.W),A0        ; calc as offset to base ...
  595.     MOVE.L    A0,-(PS)        ; ...  and push
  596.     RTS
  597.  
  598.     DC.B    64+6,'NEG'        ; "negate" ( n -- -n )
  599.     DC.W    toabs-theLink
  600. negate:    NEG    (PS)
  601.     RTS
  602.  
  603.     DC.B    5,'SPA'            ; "space" ( -- ) emit a space
  604.     DC.W    negate-theLink
  605. space:    MOVE.L    #32,D0
  606.     jmp    EmitCode-Base(BP)
  607.  
  608.     DC.B    4,'TYP'            ; "type" ( rel.addr len -- )
  609.     DC.W    space-theLink        ;  emit len characters from rel.addr
  610. Type:    MOVEM.L    D3/D4,-(SP)        ; don't trash registers!
  611.     MOVE    (PS)+,D3        ; get character count
  612.     SUBQ    #1,D3            ;    ( fixed bug )
  613.     MOVE    (PS)+,D4        ; get string relative address
  614.     @0:    MOVE.B    0(BP,D4.W),D0        ; get character byte
  615.     jsr    EmitCode-Base(BP)    ; print character byte
  616.     ADDQ    #1,D4
  617.     DBRA    D3,@0
  618.     MOVEM.L    (SP)+,D3/D4        ; restore registers
  619.     rts
  620.  
  621. pQuote:    ;   runtime part of ."
  622.     MOVE.L    (RS),-(PS)        ; push the addr of the string
  623.     JSR    torel-base(BP)
  624.     ADDQ    #1,(PS)            ; skip the length byte
  625.     MOVE.L    (RS),A0
  626.     CLR.L    D0            ; clear the character count
  627.     MOVE.B    (A0),D0            ; get the length
  628.     MOVE    D0,-(PS)        ; push it
  629.     ADDQ    #2,D0
  630.     ANDI    #$FFFE,D0        ; be sure its even
  631.     ADD.L    D0,(RS)            ; skip over string upon return
  632.     bra.s    type    ;-base(BP)        ; type the string
  633.     
  634.     DC.B    4,'EMI'            ; "emit" ( n -- ) send the ascii
  635.     DC.W    type-theLink    ;                 to the terminal
  636. Emit:    MOVE    (PS)+,D0
  637.   EmitCode:                ; Emit contents of D0
  638.     CMP.B    #13,D0            ; is it a <cr>
  639.     BEQ.S    doCR
  640.     CMP.B    #8,D0            ; is it a <del>?
  641.     BEQ.S    doDEL
  642.     ANDI    #$FF,D0
  643.     MOVE    D0,-(A7)
  644.     _DrawChar
  645.     BSR.S    penh
  646.     MOVE    WContRect+6-base(BP),D0    ; right coord of WContRect
  647.     CMP    D0,D1            ; is the position beyond the edge
  648.     BLS.S    emitr            ; no
  649.     
  650.   doCR:    PEA    Scratch-base(BP)
  651.     _GetPen
  652.     MOVE    Scratch-base(BP),D1
  653.     MOVE    WContRect+4-base(BP),D0    ; bottom coord of WContRect
  654.     SUB    #11,D0
  655.     CMP    D0,D1            ; is the position below the window
  656.     BLS.S    @0            ; no
  657.  
  658.     ; yes it is below the bottom of the window, so scroll up 11 pixels
  659.     CLR.L    -(A7)            ; Make room for a region handle.
  660.     _NewRgn                ; get handle into (A7)
  661.     PEA    WContRect-base(BP)    ; rect to scroll
  662.     CLR    -(A7)            ; no horiz.
  663.     MOVE    #$FFF5,-(A7)        ; 11 pix. vert.
  664.     MOVE.L    8(A7),-(A7)        ; push the region handle
  665.     _ScrollRect
  666.     _DisposRgn
  667.  
  668.     MOVE    WContRect+4-base(BP),D1    ; bottom coord of WContRect
  669.     SUBQ    #4,D1
  670.     BRA.S    @1
  671.  
  672.     @0: ADD    #11,D1            ; Add line height to pen location
  673.     @1:    MOVE    #1,-(A7)
  674.     MOVE    D1,-(A7)
  675.     _MoveTo
  676.  emitr:    RTS
  677.  
  678.  doDEL:    BSR.S    penh
  679.     CMP    #6,D1            ; first column?
  680.     blt.s    @0            ; don't beep anymore
  681.     SUB    #6,D1            ; back up
  682.     MOVE    D1,-(SP)
  683.     MOVE    Scratch-base(BP),-(SP)
  684.     _MoveTo
  685.     @0:    RTS
  686.  
  687.   penh:    PEA    Scratch-base(BP)
  688.     _GetPen
  689.     MOVE    Scratch+2-base(BP),D1
  690.     RTS
  691.  
  692.     DC.B    6,'EXP'            ; "expect" ( addr count -- )
  693.     DC.W    emit-theLink
  694. Expect:    MOVEM.L    D4/IS,-(SP)
  695.     JSR    swapp-base(BP)        ; leave number of chars on stack
  696.     MOVE    (PS)+,D0        ; addr
  697.     LEA    0(BP,D0.W),IS        ; set IS to the input address
  698.     CLR    Counter
  699.     MOVE    (PS)+,D4
  700.     @0:    JSR    key-base(BP)
  701.     MOVE    (PS)+,D5
  702.     CMPI    #CR,D5            ; if key = CR
  703.     BNE.S    @1
  704.     MOVE.B    #BL,0(IS,Counter)
  705.     CLR.B    1(IS,Counter)
  706.     MOVE.B    #BL,2(IS,Counter)
  707.     BRA.S    @3
  708.     @1:    CMPI    #BS,D5            ; if key = backspace
  709.     BNE.S    @2
  710.     TST    Counter            ; do nothing if first key is BS
  711.     BEQ.S    @0
  712.     SUBQ    #1,Counter        ; decriment counter
  713.     JSR    dodel-base(BP)
  714.     JSR    space-base(BP)        ;    ... rubout char
  715.     JSR    dodel-base(BP)
  716.     BRA.S    @0
  717.     @2:    MOVE.B    D5,0(IS,Counter)    ; stash the key into input buffer
  718.     ADDQ    #1,Counter
  719.     MOVE    D5,D0
  720.     JSR    emitcode-base(BP)
  721.     CMP    D4,Counter        ; is count=number of chars to get?
  722.     BNE.S    @0
  723.     @3:    JSR    docr-base(BP)
  724.     MOVEM.L    (SP)+,D4/IS
  725.     RTS
  726.  
  727.     DC.B    64+1,'0',0,0        ; "0" ( -- 0 )
  728.     DC.W    expect-theLink
  729. Zero:    CLR    -(PS)
  730.     RTS
  731.     
  732.     DC.B    64+4,'DRO'        ; "drop" ( n -- )
  733.     DC.W    zero-theLink
  734. drop:    ADDQ.L    #2,PS
  735.     RTS
  736.  
  737.     DC.B    4,'SWA'            ; "swap" ( n1 n2 -- n2 n1 )
  738.     DC.W    drop-theLink
  739. swapp:    MOVE.L    (PS)+,D0
  740.     SWAP    D0
  741.     MOVE.L    D0,-(PS)
  742.     RTS
  743.  
  744.     DC.B    64+5,'2DR'        ; "2drop" ( d -- )
  745.     DC.W    swapp-theLink
  746. TwoDrop:
  747.     ADDQ.L    #4,PS
  748.     RTS
  749.  
  750.     DC.B    4,'NUL'            ; "null" ( -- )
  751.     DC.W    twodrop-theLink
  752. Null:    RTS
  753.  
  754.     DC.B    6,'FOR'            ; "forget" ( -- ) forgets dictionary
  755.     DC.W    null-theLink
  756. Forget:    JSR    tick-base(BP)
  757.     MOVE    (PS)+,D0
  758.     MOVE    -2(BP,D0.W),Dict
  759.     LEA    -6(BP,D0.W),DP
  760.     RTS
  761.  
  762.     DC.B    8,'CON'            ; "constant" compile: ( n16 -- )
  763.     DC.W    forget-theLink    ;            runtime: ( -- n16 )
  764. Const:    JSR    token-base(BP)        ; make a header for the next token
  765.     JSR    header-base(BP)
  766.     JSR    marco-base(BP)        ; to return a constant
  767.     JSR    literal-base(BP)    ; compile time comma, runtime push
  768.     MOVE    #$4E75,(DP)+        ; compile  rts 
  769.     RTS
  770.  
  771.     DC.B    6,'CRE'            ; "create" compile: ( -- ) 
  772.     DC.W    const-theLink        ;          runtime: ( -- addr16 )
  773. Create:    JSR    token-base(BP)        ; give token this runtime action:
  774.     JSR    header-base(BP)
  775.     MOVE    #$3D3C,(DP)+        ;  • move     #nnnn,-(ps)
  776.     JSR    here-base(BP)
  777.     ADDQ    #6,(PS)
  778.     MOVE    (PS)+,(DP)+        ; supply the nnnn from above
  779.     MOVE    #$4EEB,(DP)+        ;  • jmp     null-base(bp)
  780.     MOVE.L    DP,DoesAddr-base(BP)    ; set DoesAddr to this "null"
  781.     MOVE    #null-base,(DP)+
  782.     RTS
  783.  
  784.     DC.B    5,'DOE'            ; "does>" ( -- ) (use after create)
  785.     DC.W    create-theLink        ;   set runtime action 
  786. Does:    MOVE.L    (RS)+,D0        ; pop the return address
  787.     SUB.L    BP,D0            ; convert to rel.addr
  788.     MOVE.L    DoesAddr-base(BP),A0    ; load jmp d(bp) address from create
  789.     MOVE    D0,(A0)            ; and stash rel.addr into it
  790.     RTS                ; returns same as ;
  791.  
  792.     DC.B    5,'ALL'            ; "allot" ( n16 -- )
  793.     DC.W    does-theLink        ;  compiles nada into the dictionary
  794. Allot:    ADDQ    #1,(PS)
  795.     ANDI    #$FFFE,(PS)        ; make it even!
  796.     ADDA    (PS)+,DP        ; increment the dictionary pointer
  797.     RTS
  798.  
  799.     DC.B    8,'VAR'            ; "variable" compile: ( -- )
  800.     DC.W    allot-theLink        ;            runtime: ( -- addr16 )
  801. Variable:
  802.     JSR    token-base(BP)        ; give token this runtime action:
  803.     JSR    header-base(BP)
  804.     JSR    marco-base(BP)        ; Sun May 1, 1988 04:24:44
  805.     MOVE    #$3D3C,(DP)+        ;  • move   #nnnn,-(ps)
  806.     JSR    here-base(BP)
  807.     ADDQ    #4,(PS)            ;    calculate nnnn
  808.     MOVE    (PS)+,(DP)+        ;  • (this is the nnnn)
  809.     MOVE    #$4E75,(DP)+        ;  • rts
  810.     ADDQ.L    #2,DP            ; 2 allot
  811.     RTS
  812.  
  813.     DC.B    64+5,'>NA'        ; ">name" ( 'addr -- name.addr )
  814.     DC.W    variable-theLink
  815. toname:    SUBQ    #6,(PS)
  816.     RTS
  817.     
  818.     DC.B    64+5,'>LI'        ; ">link" ( 'addr -- link.addr )
  819.     DC.W    toname-theLink
  820. tolink:    SUBQ    #2,(PS)
  821.     RTS
  822.  
  823.     DC.B    3,'ID.'            ; "id." ( addr -- )
  824.     DC.W    tolink-theLink
  825. IDDot:    JSR    toname-base(BP)
  826.     MOVEA.L    DP,A0
  827.     MOVEQ.L    #5,D0
  828.     @0:    MOVE.L    #$C9C9C9C9,(A0)+    
  829.     DBRA    D0,@0
  830.     MOVE    (PS)+,D0
  831.     MOVE.L    0(BP,D0.W),(DP)
  832.     JSR    here-base(BP)
  833.     MOVE    (PS),-(PS)
  834.     JSR    cat-base(BP)
  835.     ANDI    #$1F,(PS)        ; look at 5 lsb's
  836.     ADDQ    #1,2(PS)
  837.     JSR    type-base(BP)
  838.     JMP    space-base(BP)
  839.     
  840.     DC.B    5,'WOR'            ; "words" ( -- ) list words
  841.     DC.W    iddot-theLink
  842. Words:    MOVE.L    D3,-(SP)        ; preserve register
  843.     MOVE    Dict,D3            ; start with the last word defined
  844.     @0:    MOVE    D3,-(PS)        ; push the name address
  845.     ADDQ    #6,(PS)            ; get the CFA
  846.     BSR.S    iddot            ; print the name
  847.      MOVE    4(BP,D3.W),D3        ; put the next name addr into D3
  848.     TST.B    1(BP,D3.W)        ; Quit if name is 0
  849.     BEQ.S    @1            ; do next word if not=0
  850.     JSR    qterm-base(BP)
  851.         TST    (PS)+
  852.     BEQ.S    @0
  853.     @1:    MOVE.L    (SP)+,D3        ; restore register
  854.     RTS
  855.     
  856.     DC.B    3,'PAD'            ; "pad" ( -- ) conversion pad
  857.     DC.W    words-theLink
  858. Pad:    JSR    here-base(BP)
  859.     ADDI    #40,(PS)        ; pad is 40 bytes from HERE.
  860.     RTS
  861.     
  862.     DC.B    4,'HOL'            ; "hold" ( c -- ) place c at ...
  863.     DC.W    pad-theLink        ; ... addr in Held.
  864. Hold:    SUBQ    #1,held-base(BP)
  865.     MOVE    held-base(BP),-(PS)
  866.     JMP    cstore-base(BP)
  867.     
  868.     DC.B    4,'SIG'            ; "sign" ( sf dval -- dval )
  869.     DC.W    hold-theLink
  870. Sign:    JSR    rote-base(BP)
  871.     TST    (PS)+
  872.     BGE.S    @0
  873.     MOVE    #'-',-(PS)
  874.     BSR.S    hold
  875.     @0:    RTS
  876.  
  877.     DC.B    4,'DAB'            ; "dabs" ( dval -- |dval| )
  878.     DC.W    sign-theLink
  879. Dabs:    TST    (PS)
  880.     BGE.S    @0
  881.     JSR    dneg-base(BP)
  882.     @0:    RTS
  883.  
  884.     DC.B    2,'<#',0        ; "<#" ( -- )
  885.     DC.W    dabs-theLink
  886. LSharp:    BSR.S    pad
  887.     MOVE    (PS)+,held-base(BP)
  888.     MOVEA.L    DP,A0
  889.     MOVE    #9,D0
  890.     @0:    CLR.L    (A0)+
  891.     DBRA    D0,@0
  892.     MOVE    #30,-(PS)
  893.     BRA.S    hold
  894.  
  895.     DC.B    2,'#>'.0        ; "#>" ( dval -- addr len )
  896.     DC.W    lsharp-theLink
  897. SharpG:    ADDQ.L    #2,PS
  898.     MOVE    held-base(BP),(PS)
  899.     BSR.S    pad
  900.     MOVE    2(PS),-(PS)        ; over
  901.     ADDQ    #1,(PS)
  902.     JMP    minus-base(BP)
  903.     
  904.     DC.B    1,'#',0,0        ; "#" ( dval -- d/base )
  905.     DC.W    sharpg-theLink
  906. Sharp:    MOVE    NBase-base(BP),-(PS)
  907.     JSR    msmod-base(BP)
  908.     JSR    rote-base(BP)
  909.     CMPI    #9,(PS)            ; is top of stack < 9?
  910.     BLE.S    @0
  911.     ADDQ    #7,(PS)
  912.     @0:    ADDI    #48,(PS)
  913.     JMP    hold-base(BP)
  914.  
  915.     DC.B    2,'#S',0        ; "#s" ( dval -- 0 0 )
  916.     DC.W    sharp-theLink
  917. Sharps:    BSR.S    sharp
  918.     TST.L    (PS)
  919.     BNE.S    sharps
  920.     RTS
  921.  
  922.     DC.B    2,'D.',0        ; "d." ( dval -- )
  923.     DC.W    sharps-theLink
  924. DDot:    JSR    swapp-base(BP)
  925.     MOVE    2(PS),-(PS)
  926.     JSR    dabs-base(BP)
  927.     BSR.S    lsharp
  928.     BSR.S    sharps
  929.     JSR    sign-base(BP)
  930.     BSR.S    sharpg
  931.     jsr    type-base(BP)
  932.     jmp    space-base(bp)
  933.  
  934.     DC.B    2,'U.',0        ; "u." ( uval -- )
  935.     DC.W    ddot-theLink
  936. UDot:    CLR    -(PS)
  937.     BRA.S    ddot
  938.  
  939.     DC.B    3,'S>D'            ; "s>d" ( n -- d )
  940.     DC.W    udot-theLink
  941. SToD:    MOVE    (PS),-(PS)        ; dup
  942.     JMP    zerolt-base(BP)        ; 0<
  943.  
  944.     DC.B    1,'.',0,0        ; "." ( n -- )
  945.     DC.W    stod-theLink
  946. Dot:    BSR.S    stod
  947.     BRA.S    ddot
  948.  
  949.     DC.B    130,'."',0        ; "."" ( -- ) compiler part of (.")
  950.     DC.W    dot-theLink
  951. dotQ:    MOVE    #pQuote-base,-(PS)
  952.     JSR    compile-base(BP)    ; compile a call to (.")
  953.     JSR    here-base(BP)        ; ( -- addr )
  954.     MOVE    #'"',-(PS)        ; ( -- addr 34 )
  955.     JSR    word-base(BP)        ; ( -- addr )
  956.     JSR    cat-base(BP)        ; ( -- c )
  957.     ADDQ    #1,(PS)            ; ( -- c+1 )
  958.     JMP    allot-base(BP)        ; enclose the string in dictionary
  959.     
  960.     DC.B    129,'(',0,0        ; "(" ( -- ) begin comment
  961.     DC.W    dotq-theLink
  962. Comment    CMPI.B    #41,(IS)+        ; read in characters until ")"
  963.     BNE.S    Comment
  964.     RTS
  965.  
  966.     DC.B    5,'CMO'            ; "cmove" ( addr1 addr2 len -- )
  967.     DC.W    comment-theLink        ; from figFORTH, fixed 8/3/91
  968. CMove:    MOVE    (PS)+,D0        ; D0 = length
  969.     MOVE    (PS)+,D1
  970.     LEA    0(BP,D1.W),A1        ; A1 = addr2
  971.     MOVE    (PS)+,D1
  972.     LEA    0(BP,D1.W),A0        ; A0 = addr1
  973.     CMPA.L    A0,A1
  974.     BPL.S    @2
  975.  
  976.     BRA.S    @1            ;  addr1 > addr2
  977.     @0:    MOVE.B    (A0)+,(A1)+
  978.     @1:    DBRA    D0,@0
  979.     RTS
  980.  
  981.     @2:    ADDA    D0,A0            ;  addr1 ≤ addr2
  982.     ADDA    D0,A1
  983.     BRA.S    @4
  984.     @3:    MOVE.B    -(A0),-(A1)
  985.     @4:    DBRA    D0,@3
  986.     RTS
  987.     
  988.     DC.B    4,'FIL'            ; "fill" ( addr count char -- )
  989.     DC.W    cmove-theLink
  990. Fill:    MOVE    (PS)+,D0        ; character
  991.     MOVE    (PS)+,D1        ; count
  992.     SUBQ    #1,D1            ; decrement count
  993.     MOVE    (PS)+,A0        ; relative addr
  994.     LEA    0(BP,A0.W),A0        ; get absolute addr
  995.     @0:    MOVE.B    D0,0(A0,D1.W)        ; put char into addr + count
  996.         DBRA    D1,@0            ; decrement count & loop until 0
  997.     RTS
  998.     
  999.     DC.B    9,'-TR'            ; "-trailing"
  1000.     DC.W    fill-theLink        ;  ( addr count -- addr new.count )
  1001. dtrail:    MOVE    (PS)+,D1        ; get the count
  1002.     MOVE    (PS),D0            ; get the rel.addr
  1003.     LEA    0(BP,D0.W),A0        ; get the abs.addr
  1004.     @0:    CMPI.B    #$20,-1(A0,D1.W)    ; BEGIN  is char at addr+count $20
  1005.     DBNE    D1,@0            ; NOT UNTIL
  1006.     MOVE    D1,-(PS)        ; put new count on stack
  1007.     RTS
  1008.     
  1009.     DC.B    64+2,'1+',0        ; "1+" ( n -- n+1 )
  1010.     DC.W    dtrail-theLink
  1011. OnePl:    ADDQ    #1,(PS)
  1012.     RTS
  1013.  
  1014.     DC.B    64+2,'1-',0        ; "1-" ( n -- n-1 )
  1015.     DC.W    onepl-theLink
  1016. OneMi:    SUBQ    #1,(PS)
  1017.     RTS
  1018.     
  1019.     DC.B    64+2,'2+',0        ; "2+" ( n -- n+2 )
  1020.     DC.W    onemi-theLink
  1021. TwoPl:    ADDQ    #2,(PS)
  1022.     RTS
  1023.     
  1024.     DC.B    64+2,'2*',0        ; "2*" ( n -- n*2 )
  1025.     DC.W    twopl-theLink
  1026. ToStar:    ASL    (PS)
  1027.     RTS
  1028.  
  1029.     DC.B    64+2,'2/',0        ; "2/" ( n -- n/2 )
  1030.     DC.W    tostar-theLink
  1031. ToDiv:    ASR    (PS)
  1032.     RTS
  1033.  
  1034.     DC.B    5,'DEP'            ; "depth" ( -- n )
  1035.     DC.W    ToDiv-theLink        ; 16 bit entries on stack before this
  1036. depth:    move.l    szero-base(bp),d0
  1037.     sub.l    ps,d0
  1038.     move    d0,-(ps)
  1039.     bra.s    todiv
  1040.  
  1041.     DC.B    1,'@',0,0        ; "@" (at) ( addr16 -- n16 )
  1042.     DC.W    depth-theLink
  1043. At:    MOVE    (PS),D0            ; DANGER: odd values crash this
  1044.     MOVE    0(BP,D0.W),(PS)    
  1045.     RTS
  1046.  
  1047.     DC.B    1,'!',0,0        ; "!" (store) ( n16 addr16 -- )
  1048.     DC.W    at-theLink
  1049. Store:    MOVE    (PS)+,D0        ; DANGER: odd values crash this
  1050.     MOVE    (PS)+,0(BP,D0.W)
  1051.     RTS
  1052.  
  1053.     DC.B    2,'C!',0        ; "c!" (sea-store)( n8 addr16 -- )
  1054.     DC.W    store-theLink
  1055. CStore:    MOVE    (PS)+,D0        ; get the rel.addr (odd OK)
  1056.     ADDQ.L    #1,PS            ; align the stack
  1057.     MOVE.B    (PS)+,0(BP,D0.W)    ; put data at the addr
  1058.     RTS
  1059.  
  1060.     DC.B    2,'C@',0        ; "c@" (sea-at) ( addr16 -- n8 )
  1061.     DC.W    cstore-theLink
  1062. CAt:    MOVE    (PS),D0            ; get rel.addr (odd OK)
  1063.     CLR    (PS)            ; clear the result
  1064.     MOVE.B    0(BP,D0.W),1(PS)    ; stash the second byte
  1065.     RTS
  1066.  
  1067.     DC.B    64+2,'L@',0        ; "l@" (el-at) ( daddr32 -- n16 )
  1068.     DC.W    cat-theLink
  1069. LAt:    MOVEA.L    (PS)+,A0        ; get the double number "real" addr
  1070.     MOVE    (A0),-(PS)        ; fetch the contents
  1071.     RTS
  1072.  
  1073.     DC.B    64+2,'L!',0        ; "l!" (el-store)( n16 daddr32 -- )
  1074.     DC.W    lat-theLink
  1075. LStore:    MOVEA.L    (PS)+,A0
  1076.     MOVE    (PS)+,(A0)
  1077.     RTS
  1078.     
  1079.     DC.B    64+3,'DL@'        ; "dl@" ( daddr32 -- d32 )
  1080.     DC.W    lstore-theLink
  1081. DLAt:    MOVEA.L    (PS),A0
  1082.     MOVE.L    (A0),(PS)
  1083.     RTS
  1084.     
  1085.     DC.B    64+3,'DL!'        ; "dl!" ( d32 daddr32 -- )
  1086.     DC.W    dlat-theLink
  1087. DLStor:    MOVE.L    (PS)+,A0
  1088.     MOVE.L    (PS)+,(A0)
  1089.     RTS
  1090.  
  1091.     DC.B    2,'+!',0        ; "+!" ( n16 addr16 -- )
  1092.     DC.W    dlstor-theLink
  1093. pstore:    MOVE    (PS)+,D0
  1094.     MOVE    (PS)+,D1
  1095.     ADD    D1,0(BP,D0.W)
  1096.     RTS
  1097.     
  1098.     DC.B    64+4,'CBL'        ; "cblk" ( -- addr ) of fint
  1099.     DC.W    pstore-theLink
  1100. cBLK:    MOVE    #fint-base,-(PS)
  1101.     RTS
  1102.     
  1103.     DC.B    64+6,'CST'        ; "cstate" ( -- addr ) of fcolon
  1104.     DC.W    cblk-theLink
  1105. cState:    MOVE    #fcolon-base,-(PS)
  1106.     RTS
  1107.  
  1108.     DC.B    64+4,'BAS'        ; "base" ( -- addr )
  1109.     DC.W    cstate-theLink        ;   variable for the numeric radix
  1110. BaseA:    MOVE    #nbase-base,-(PS)
  1111.     RTS
  1112.  
  1113.     DC.B    64+3,'TIB'        ; "tib" ( -- addr )
  1114.     DC.W    basea-theLink        ;   variable for Terminal Input Buf.
  1115. TIB:    MOVE    #termbuf-base,-(PS)
  1116.     RTS
  1117.  
  1118.     DC.B    64+6,'LAT'        ; "latest" ( -- addr )
  1119.     DC.W    tib-theLink        ;   variable for the last dict word
  1120. Latest:    MOVE    Dict,-(PS)        ; push contents of the dict register
  1121.     RTS
  1122.  
  1123.     DC.B    64+3,'R0@'        ; "r0@" ( -- dabs.addr )
  1124.     DC.W    latest-theLink        ;   dabs.addr of r0
  1125. R0at:    MOVE.L    rzero-base(BP),-(PS)
  1126.     RTS
  1127.  
  1128.     DC.B    64+3,'RP@'        ; "rp@" ( -- dabs.addr )
  1129.     DC.W    r0at-theLink        ;   current addr of the return stack
  1130. RPat:    MOVE.L    RS,-(PS)
  1131.     RTS
  1132.  
  1133.     DC.B    64+3,'S0@'        ; "s0@" ( -- dabs.addr )
  1134.     DC.W    rpat-theLink        ;   dabs.addr of s0
  1135. S0at:    MOVE.L    szero-base(BP),-(PS)
  1136.     RTS
  1137.  
  1138.     DC.B    64+3,'SP@'        ; "sp@" ( -- dabs.addr )
  1139.     DC.W    s0at-theLink        ; address of the current stack cell
  1140. SPat:    MOVE.L    PS,-(PS)
  1141.     RTS
  1142.  
  1143.     DC.B    3,'HEX'            ; "hex" ( -- )
  1144.     DC.W    spat-theLink
  1145. hex:    MOVE    #$10,nbase-base(BP)
  1146.     RTS
  1147.  
  1148.     DC.B    7,'DEC'            ; "decimal" ( -- )
  1149.     DC.W    hex-theLink
  1150. decimal    MOVE    #10,nbase-base(BP)
  1151.     RTS
  1152.     
  1153.     DC.B    4,'?DU'            ; "?dup" ( n -- n n OR n [if n=0] )
  1154.     DC.W    decimal-theLink
  1155. qdup:    TST    (PS)
  1156.     BNE.S    dup
  1157.     RTS
  1158.  
  1159.     DC.B    64+3,'DUP'        ; "dup" ( n -- n n )
  1160.     DC.W    qdup-thelink
  1161. dup:    MOVE    (PS),-(PS)
  1162.     RTS
  1163.  
  1164.     DC.B    64+4,'OVE'        ; "over" ( n1 n2 -- n1 n2 n1 )
  1165.     DC.W    dup-theLink
  1166. over:    MOVE    2(PS),-(PS)
  1167.     RTS
  1168.  
  1169.     DC.B    3,'ROT'            ; "rot" ( n1 n2 n3 -- n2 n3 n1 )
  1170.     DC.W    over-theLink
  1171. rote:    MOVE.L    (PS)+,D0
  1172.     MOVE    (PS)+,D1
  1173.     MOVE.L    D0,-(PS)
  1174.     MOVE    D1,-(PS)
  1175.     RTS
  1176.  
  1177.     DC.B    64+4,'2DU'        ; "2dup" ( n1 n2 -- n1 n2 n1 n2 )
  1178.     DC.W    rote-theLink
  1179. todup:    MOVE.L    (PS),-(PS)
  1180.     RTS
  1181.  
  1182.     DC.B    5,'2SW'            ; "2swap"
  1183.     DC.W    todup-theLink        ;  ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
  1184. toswap:    MOVE.L    (PS)+,D0
  1185.     MOVE.L    (PS)+,D1
  1186.     MOVE.L    D0,-(PS)
  1187.     MOVE.L    D1,-(PS)
  1188.     RTS
  1189.     
  1190.     DC.B    64+2,'>R',0        ; ">r" ( n -- ) rstack: ( -- n16 )
  1191.     DC.W    toswap-theLink
  1192. toR:    MOVE    (PS)+,-(RS)
  1193.     RTS
  1194.  
  1195.     DC.B    64+2,'R>',0        ; "r>" ( -- n ) rstack: ( n16 -- )
  1196.     DC.W    tor-theLink
  1197. Rfrom:    MOVE    (RS)+,-(PS)
  1198.     RTS
  1199.  
  1200.     DC.B    64+1,'R',0,0        ; "r" ( -- n ) rs: ( n16 -- n16 )
  1201.     DC.W    rfrom-theLink
  1202. Are:    MOVE    (RS),-(PS)
  1203.     RTS
  1204.  
  1205.     DC.B    4,'EXI'            ; "exit" ( -- ) drops return address
  1206.     DC.W    are-theLink
  1207. Exit:    ADDQ.L    #4,RS
  1208.     RTS
  1209.  
  1210.     DC.B    1,'*',0,0        ; "*" ( n1 n2 -- n1*n2 )
  1211.     DC.W    exit-theLink
  1212. times:    MOVE    (PS)+,D0
  1213.     MULS    (PS)+,D0
  1214.     MOVE    D0,-(PS)
  1215.     RTS
  1216.  
  1217.     DC.B    4,'/MO'            ; "/mod ( n1 n2 -- rem quot )
  1218.     DC.W    times-theLink
  1219. Smod:    MOVE    (PS)+,D0
  1220.     BNE.S    @0
  1221.     BRA.S    sfail
  1222.     @0:    MOVE    (PS)+,D1
  1223.     EXT.L    D1
  1224.     DIVS    D0,D1
  1225.     SWAP    D1
  1226.     MOVE.L    D1,-(PS)
  1227.     RTS
  1228.  
  1229.     DC.B    1,'/',0,0        ; "/" ( n1 n2 -- quotient )
  1230.     DC.W    smod-theLink
  1231. Slash:    JSR    smod-base(BP)
  1232.     JSR    swapp-base(BP)
  1233.     ADDQ.L    #2,PS
  1234.     RTS
  1235.  
  1236.     DC.B    3,'MOD'            ; "mod"    ( n1 n2 -- remainder )
  1237.     DC.W    slash-theLink
  1238. mod:    JSR    smod-base(BP)
  1239.     ADDQ.L    #2,PS
  1240.     RTS
  1241.  
  1242.     DC.B    2,'*/',0        ; "*/" ( n1 n2 n3 -- n1*n2/n3 )
  1243.     DC.W    mod-theLink
  1244. SSlash:    MOVE    (PS)+,D1
  1245.     BNE.S    sok
  1246.     ADDQ.L    #2,PS
  1247.  sfail:    MOVE    #-1,(PS)
  1248.     RTS
  1249.    sok:    MOVE    (PS)+,D0
  1250.     MULS    (PS),D0
  1251.     DIVS    D1,D0
  1252.     MOVE    D0,(PS)
  1253.     RTS
  1254.  
  1255.     DC.B    2,'U*',0        ; "u*" ( n1 n2 -- d32 )
  1256.     DC.W    sslash-theLink
  1257. UStar:    MOVE    (PS)+,D0
  1258.     MULU    (PS)+,D0
  1259.     MOVE.L    D0,-(PS)
  1260.     RTS
  1261.     
  1262.     DC.B    5,'M/M'            ; "m/mod" from King&Knight
  1263.     DC.W    ustar-theLink        ; ( num32 denom16 -- rem16 quot32 )
  1264. MSMod:    TST    (PS)            ; test for div by zero
  1265.     BNE.S    @0
  1266.     ADDQ.L    #4,PS
  1267.     BRA.S    sfail
  1268.     @0:    MOVE.L    D2,-(SP)        ; save D2
  1269.     MOVEQ    #0,D2            ; clear it
  1270.     MOVE    (PS)+,D2        ; pop denom into D2.W
  1271.     MOVE.L    (PS)+,D1        ; pop num into D1.L
  1272.     MOVE    D1,-(SP)        ; hold num.l on rstack
  1273.     CLR    D1
  1274.     SWAP    D1
  1275.     DIVU    D2,D1
  1276.     MOVE    D1,D0
  1277.     MOVE    (SP)+,D1
  1278.     DIVU    D2,D1
  1279.     SWAP    D1
  1280.     MOVE    D1,-(PS)        ; push remainder
  1281.     MOVE    D0,D1
  1282.     SWAP    D1
  1283.     MOVE.L    D1,-(PS)        ; push quotient
  1284.     MOVE.L    (SP)+,D2        ; restore register
  1285.     RTS
  1286.     
  1287.     DC.B    64+7,'DNE'        ; "dnegate" ( d32 -- -d32 )
  1288.     DC.W    msmod-theLink
  1289. DNeg:    NEG.L    (PS)
  1290.     RTS
  1291.     
  1292.     DC.B    64+2,'D+',0        ; "d+" ( d1 d2 -- d1+d2 )
  1293.     DC.W    dneg-theLink
  1294. DPlus:    MOVE.L    (PS)+,D0
  1295.     ADD.L    D0,(PS)
  1296.     RTS
  1297.     
  1298.     DC.B    128+2,'IF',0        ; "if" ( flag -- ) at runtime
  1299.     DC.W    dplus-theLink        ;      ( -- addr ) at compile time
  1300. pIf:    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1301.   pi1:    bsr.s    pbegin
  1302.     ADDQ.L    #2,DP            ; make room for offset
  1303.     RTS
  1304.     
  1305.     DC.B    128+5,'WHI'        ; "while" ( flag -- ) at runtime
  1306.     DC.W    pif-theLink        ;    ( -- addr ) at compile time
  1307. pWhile:    BRA.S    pIf
  1308.     
  1309.     DC.B    128+4,'ELS'        ; "else" ( -- ) at runtime
  1310.     DC.W    pwhile-theLink        ; ( addr -- addr ) at compile time
  1311. pElse:    MOVE    #$6000,(DP)+
  1312.     bsr.s    pi1
  1313.     JSR    swapp-base(BP)
  1314.     BRA.S    pthen
  1315.  
  1316.     DC.B    128+4,'THE'        ; "then" ( -- ) at runtime
  1317.     DC.W    pelse-theLink        ;   ( addr -- ) at compile time
  1318. pThen:    bsr.s    pbegin
  1319.     MOVE    2(PS),-(PS)        ; over
  1320.     JSR    minus-base(BP)
  1321.     JSR    swapp-base(BP)
  1322.     JMP    store-base(BP)
  1323.  
  1324.     DC.B    128+6,'REP'        ; "repeat" ( -- ) at runtime
  1325.     DC.W    pthen-theLink        ; ( b.addr w.addr -- ) at c.time
  1326. pRepet:    MOVE    #$6000,(DP)+        ; compile bra ...
  1327.     JSR    swapp-base(BP)
  1328.     BSR.S    back
  1329.     BRA.S    pThen            ; HERE OVER - SWAP ! ;
  1330.  
  1331.     DC.B    128+5,'BEG'        ; "begin" ( -- ) at runtime
  1332.     DC.W    prepet-theLink        ;    ( -- addr ) at compile time
  1333. pBegin:    JMP    here-base(BP)
  1334.  
  1335.     DC.B    128+5,'UNT'        ; "until" ( flag -- ) at runtime
  1336.     DC.W    pbegin-theLink        ;      ( addr -- ) at compile time
  1337. pUntil    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1338.     BRA.S    back
  1339.     
  1340.     DC.B    128+5,'AGA'        ; "again" ( -- ) at runtime
  1341.     DC.W    puntil-theLink        ;    ( addr -- ) at compile time
  1342. pAgain:    MOVE    #$6000,(DP)+        ; compile bra ...
  1343.     BRA.S    back
  1344.  
  1345.     DC.B    4,'BAC'            ; "back" ( addr -- )
  1346.     DC.W    pagain-theLink        ;  compile negative displacement
  1347. back:    bsr.s    pbegin
  1348.     JSR    minus-base(BP)
  1349.     MOVE    (PS),D0            ; get the target addr into d0
  1350.     BGE.S    @0
  1351.     NEG    D0            ; make it positive
  1352.     @0:    ANDI    #$FF80,D0        ; if > 1 byte
  1353.     BEQ.S    @1
  1354.     JMP    comma-base(BP)        ; then comma it as a long branch
  1355.     @1:    MOVE.B    1(PS),-1(DP)        ; else make it a short branch
  1356.     JMP    drop-base(BP)
  1357.  
  1358.     DC.B    128+2,'DO',0        ; "do" ( -- addr ) at compile time
  1359.     DC.W    back-theLink        ;  ( limit index -- ) at runtime
  1360. do:    MOVE    #$2F1E,(DP)+        ; • move.l (ps)+,-(ps)
  1361.     bra.s    pbegin
  1362.     
  1363.     DC.B    128+4,'LOO'        ; "loop" ( -- ) at runtime
  1364.     DC.W    do-theLink        ;   ( addr -- ) at compile time
  1365. Loop:    MOVE.L    #$52573017,(DP)+    ;  • addq #1,(rs) • move (rs),d0  (increment ix)
  1366.     MOVE.L    #$B06F0002,(DP)+    ;  • cmp  2(rs),d0 (check lim)
  1367.     MOVE    #$6B00,(DP)+        ;  • bmi  ...      (loop if ix<lim)
  1368.   pl:    BSR.S    back            ; comma in the displacement to 'do'
  1369.     MOVE    #$588F,(DP)+        ;  • addq.l #4,rs    (drop ix&lim)
  1370.     RTS
  1371.     
  1372.     DC.B    128+5,'+LO'        ; "+loop" ( n -- ) at runtime
  1373.     DC.W    loop-theLink        ;   ( addr -- ) at compile time
  1374. pLoop:    MOVE    #$4EAB,(DP)+
  1375.     MOVE    #ppl-base,(DP)+        ;  • jsr ppl-base(bp)
  1376.     MOVE    #$6700,(DP)+        ;  • beq  ...  (neg flag change)
  1377.     BRA.S    pl
  1378.  
  1379. ppl:    MOVE    4(A7),D0        ; get index
  1380.     CMP    6(A7),D0        ; check limit
  1381.     MOVE    SR,D1            ; hold result
  1382.     MOVE     (PS)+,D0        ; get step 
  1383.     ADD    D0,4(A7)        ; incerment index
  1384.     MOVE    4(A7),D0        ; get new index
  1385.     CMP    6(A7),D0        ; check new limit
  1386.     MOVE    SR,D0            ; hold it
  1387.     EOR    D0,D1            ; mix with last result
  1388.     AND    #8,D1            ; check for change in neg flag
  1389.     RTS
  1390.     
  1391.     DC.B    5,'LEA'            ; "leave" ( -- )
  1392.     DC.W    ploop-theLink        ;  set the index to the limit
  1393. Leave:    MOVE    6(RS),4(RS)
  1394.     RTS
  1395.  
  1396.     DC.B    2,'0<',0        ; "0<" ( n -- flag )
  1397.     DC.W    leave-theLink
  1398. ZeroLT:    TST    (PS)
  1399.     BLT.S    true
  1400.  false:    CLR    (PS)
  1401.     RTS
  1402.  true:    MOVE    #-1,(PS)
  1403.     RTS
  1404.  
  1405.     DC.B    2,'0>',0        ; "0>" ( n -- flag )
  1406.     DC.W    zerolt-theLink
  1407. ZeroGT:    NEG    (PS)
  1408.     BRA.S    zerolt
  1409.  
  1410.     DC.B    2,'0=',0        ; "0=" ( n -- flag )
  1411.     DC.W    zerogt-theLink
  1412. ZeroEQ:    TST    (PS)
  1413.     BEQ.S    true
  1414.     BRA.S    false
  1415.  
  1416.     DC.B    64+1,'+',0,0        ; "+" ( n1 n2 -- n1+n2 )
  1417.     DC.W    zeroeq-theLink
  1418. plus:    MOVE    (PS)+,D0
  1419.     ADD    D0,(PS)
  1420.     RTS
  1421.  
  1422.     DC.B    1,'-',0,0        ; "-" ( n1 n2 -- n1-n2 )
  1423.     DC.W    plus-theLink
  1424. minus:    NEG    (PS)
  1425.     bra.s    plus
  1426.  
  1427.     DC.B    1,'=',0,0        ; "=" ( n1 n2 -- flag )
  1428.     DC.W    minus-theLink
  1429. equal:    bsr.s    minus
  1430.     BRA.S    zeroeq
  1431.  
  1432.     DC.B    1,'<',0,0        ; "<" ( n1 n2 -- flag )
  1433.     DC.W    equal-theLink
  1434. lesst:    bsr.s    minus
  1435.     BRA.S    zerolt
  1436.  
  1437.     DC.B    1,'>',0,0        ; ">" ( n1 n2 -- flag )
  1438.     DC.W    lesst-theLink
  1439. moret:    bsr.s    minus
  1440.     BRA.S    zerogt
  1441.  
  1442.     DC.B    64+3,'AND'        ; "and"    ( n1 n2 -- n1(and)n2 )
  1443.     DC.W    moret-theLink
  1444. andd:    MOVE    (PS)+,D0
  1445.     AND    D0,(PS)
  1446.     RTS
  1447.  
  1448.     DC.B    64+2,'OR',0        ; "or" ( n1 n2 -- n1(or)n2 )
  1449.     DC.W    andd-theLink
  1450. orr:    MOVE    (PS)+,D0
  1451.     OR    D0,(PS)
  1452.     RTS
  1453.     
  1454.     DC.B    64+3,'XOR'        ; "xor" ( n1 n2 -- n1(xor)n2 )
  1455.     DC.W    orr-theLink
  1456. xor:    MOVE    (PS)+,D0
  1457.     EOR    D0,(PS)
  1458.     RTS
  1459.  
  1460.     DC.B    3,'ABS'            ; "abs"    ( n1 -- abs(n1) )
  1461.     DC.W    xor-theLink
  1462. abs:    TST    (PS)
  1463.     BGE.S    @0
  1464.     NEG    (PS)
  1465.     @0:    RTS
  1466.  
  1467.         DC.B    3,'MIN'            ; "min" ( n1 n2 -- n(min) )
  1468.     DC.W    abs-theLink
  1469. min:    MOVE    (PS)+,D0
  1470.     CMP    (PS),D0
  1471.     BLT.S    pd0
  1472.     RTS
  1473.    pd0:    MOVE    D0,(PS)
  1474.     RTS
  1475.  
  1476.         DC.B    3,'MAX'            ; "max" ( n1 n2 -- n(max) )
  1477.     DC.W    min-theLink
  1478. max:    MOVE    (PS)+,D0
  1479.     CMP    (PS),D0
  1480.     BGE.S    pd0
  1481.     RTS
  1482.  
  1483.     DC.B    2,'2@',0        ; "2@" ( addr -- d )
  1484.     DC.W    max-theLink        ; 32 bit fetch
  1485. TwoAt:    MOVE    (PS)+,D0
  1486.     MOVE.L    0(BP,D0.W),-(PS)
  1487.     RTS
  1488.  
  1489.     DC.B    2,'2!',0        ; "2!" ( d addr -- )
  1490.     DC.W    twoat-theLink        ; 32 bit store
  1491. TwoStore:
  1492.     MOVE    (PS)+,D0
  1493.     MOVE.L    (PS)+,0(BP,D0.W)
  1494.     RTS
  1495.  
  1496.     DC.B    9,'2CO'            ; "2constant"
  1497.     DC.W    twostore-theLink    ; defining: ( d -- )
  1498. TwoCon:    JSR    token-base(BP)        ; executing: ( -- d )
  1499.     JSR    header-base(BP)
  1500.     JSR    dlit-base(BP)
  1501.     MOVE    #$4E75,(DP)+
  1502.     RTS
  1503.  
  1504.     DC.B    9,'2VA'            ; "2variable"
  1505.     DC.W    twocon-theLink        ; defining: ( -- )
  1506. TwoVar:    JSR    variable-base(BP)    ; executing: ( -- addr )
  1507.     ADDQ.L    #2,DP
  1508.     RTS
  1509.  
  1510.     DC.B    64+3,'2>R'        ; "2>r" ( d -- ) rstack: ( -- d )
  1511.     DC.W    twovar-theLink
  1512. TwoToR:    MOVE.L    (PS)+,-(RS)
  1513.     RTS
  1514.  
  1515.     DC.B    64+3,'2R>'        ; "2r>" ( -- d ) rstack: ( d -- )
  1516.     DC.W    twotor-theLink
  1517. TwoRFrom:
  1518.     MOVE.L    (RS)+,-(PS)
  1519.     RTS
  1520.     
  1521.     DC.B    3,'A>R'            ; "a>r" ( addr -- )
  1522.     DC.W    tworfrom-theLink    ;   rstack: ( -- dabs.addr )
  1523. AToR:    JSR    toabs-base(BP)
  1524.     MOVE.L    (SP)+,A0
  1525.     MOVE.L    (PS)+,-(SP)
  1526.     JMP    (A0)
  1527.  
  1528.     DC.B    64+5,'2OV'        ; "2over" ( d1 d2 -- d1 d2 d1 )
  1529.     DC.W    ator-theLink
  1530. TwoOver:
  1531.     MOVE.L    4(PS),-(PS)
  1532.     RTS
  1533.  
  1534.     DC.B    4,'2RO'            ; "2rot" ( d1 d2 d3 -- d2 d3 d1 )
  1535.     DC.W    twoover-theLink
  1536. TwoRot:    MOVE.L    (PS)+,D0
  1537.     MOVE.L    (PS)+,D1
  1538.     MOVE.L    (PS),A0
  1539.     MOVE.L    D1,(PS)
  1540.     MOVE.L    D0,-(PS)
  1541.     MOVE.L    A0,-(PS)
  1542.     RTS
  1543.  
  1544. ; floating point stack manipulation
  1545.     DC.B    64+5,'FDR'        ; FDROP ( n1 n2 n3 n4 n5 -- )
  1546.     DC.W    tworot-theLink
  1547. fdrop:    ADDQ.L    #6,PS
  1548.     ADDQ.L    #4,PS
  1549.     RTS
  1550.  
  1551.     DC.B    4,'FDU'        ; FDUP ( n5 n4 n3 n2 n1 -- n5 n4 n3 n2 n1  n5 n4 n3 n2 n1 )
  1552.     DC.W    fdrop-theLink
  1553. fdup:    LEA    10(PS),A0
  1554.     MOVE.L    -(A0),-(PS)
  1555.     MOVE.L    -(A0),-(PS)
  1556.     MOVE.W    -(A0),-(PS)
  1557.     RTS
  1558.  
  1559.     DC.B    5,'FSW'            ; FSWAP ( f1 f2 -- f2 f1 )
  1560.     DC.W    fdup-theLink
  1561. fswap:    LEA    (PS),A0
  1562.     LEA    10(PS),A1
  1563.     MOVEQ    #4,D1
  1564.     @0:    MOVE    (A1),D0
  1565.     MOVE    (A0),(A1)+
  1566.     MOVE    D0,(A0)+
  1567.     DBRA    D1,@0
  1568.     RTS
  1569.  
  1570.     DC.B    5,'FPI'            ; FPICK ( fn..f1 m|n≥m≥1 -- fn..f1 fm )
  1571.     DC.W    fswap-theLink
  1572. fpick:    MOVE    #$0A,-(PS)
  1573.     JSR    times-base(BP)
  1574.     MOVE    (PS)+,D0
  1575.     LEA    0(PS,D0.W),A0
  1576.     MOVE.L    -(A0),-(PS)
  1577.     MOVE.L    -(A0),-(PS)
  1578.     MOVE    -(A0),-(PS)
  1579.     RTS
  1580.  
  1581.     DC.B    5,'FPA'        ; FPACK ( fn..f1 fnew m -- fn..f1 ) ( fm = fnew )
  1582.     DC.W    fpick-theLink
  1583. fpack:    MOVE    #$0A,-(PS)
  1584.     JSR    times-base(BP)
  1585.     MOVE    (PS)+,D0
  1586.     LEA    0(PS,D0.W),A0
  1587.     MOVE.L    (PS)+,(A0)+
  1588.     MOVE.L    (PS)+,(A0)+
  1589.     MOVE    (PS)+,(A0)+
  1590.     RTS
  1591.  
  1592.     DC.B    5,'FRO'        ; FROLL ( fn..f1 m -- fn..fm+1 fm-1..f1 fm )
  1593.     DC.W    fpack-theLink
  1594. froll:    bsr.s    fpick
  1595.     LSR.W    #1,D0
  1596.     subq    #1,d0
  1597.     @0:    MOVE    -(A0),10(A0)
  1598.     DBRA    D0,@0
  1599.     JSR    fswap-base(BP)
  1600.     JMP    fdrop-base(BP)
  1601.  
  1602. ; float - double number conversion
  1603.     DC.B    3,'D>F'            ; D>F ( d -- n1 n2 n3 n4 n5 )
  1604.     DC.W    froll-theLink
  1605. dtof:    MOVE.L    (PS)+,(DP)
  1606.     MOVE.L    DP,-(RS)
  1607.     SUBQ.L    #6,PS
  1608.     SUBQ.L    #4,PS
  1609.     PEA    (PS)
  1610.     FL2X
  1611.     RTS
  1612.  
  1613.     DC.B    3,'F>D'            ; F>D ( n1 n2 n3 n4 n5 -- d )
  1614.     DC.W    dtof-theLink
  1615. ftod:    PEA    (PS)
  1616.     MOVE.L    DP,-(RS)
  1617.     FX2L
  1618.     JSR    fdrop-base(BP)  
  1619.     MOVE.L    (DP),-(PS)
  1620.     RTS
  1621.  
  1622.     DC.B    2,'F@',0        ; F@ ( addr -- n5 n4 n3 n2 n1 )
  1623.     DC.W    ftod-theLink
  1624. fat:    MOVE    (PS)+,D0
  1625.     LEA    10(BP,D0.W),A0
  1626.     MOVE.L    -(A0),-(PS)
  1627.     MOVE.L    -(A0),-(PS)
  1628.     MOVE    -(A0),-(PS)
  1629.     RTS
  1630.  
  1631.     DC.B    2,'F!',0        ; F! ( n5 n4 n3 n2 n1 addr -- )
  1632.     DC.W    fat-theLink
  1633. fstore:    MOVE    (PS)+,D0
  1634.     LEA    0(BP,D0.W),A0
  1635.     MOVE.L    (PS)+,(A0)+
  1636.     MOVE.L    (PS)+,(A0)+
  1637.     MOVE    (PS)+,(A0)
  1638.     RTS
  1639.  
  1640.     DC.B    2,'F,',0        ; F, ( n5 n4 n3 n2 n1 -- )
  1641.     DC.W    fstore-theLink
  1642. fcomma:    MOVE.L    (PS)+,(DP)+
  1643.     MOVE.L    (PS)+,(DP)+
  1644.     MOVE    (PS)+,(DP)+
  1645.     RTS
  1646.  
  1647.     DC.B    9,'FCO'        ; FCONSTANT ( comp: f -- ) ( run: -- f )
  1648.     DC.W    fcomma-theLink
  1649. fcon:    JSR    create-base(BP)
  1650.     BSR.S    fcomma
  1651.     JSR    does-base(BP)
  1652.     BRA.S    fat
  1653.  
  1654.     DC.B    9,'FVA'        ; FVARIABLE ( compile: -- ) ( run: -- addr )
  1655.     DC.W    fcon-theLink
  1656. fvar:    JSR    variable-base(BP)
  1657.     ADDQ.L #8,DP
  1658.     RTS
  1659.  
  1660.     DC.B    3,'SCI'            ; SCI ( decimal.places -- )
  1661.     DC.W    fvar-theLink
  1662. sci:    CLR    -(PS)
  1663.   sci1:    MOVE.L    (PS)+,form-base(BP)
  1664.     RTS
  1665.  
  1666.     DC.B    3,'FIX'            ; FIX ( decimal.places -- )
  1667.     DC.W    sci-theLink
  1668. fix:    MOVE    #$FFFF,-(PS)
  1669.     BRA.S    sci1
  1670.  
  1671.     DC.B    2,'F.',0        ; F. ( n5 n4 n3 n2 n1 -- )
  1672.     DC.W    fix-theLink
  1673. fdot:    PEA    form-base(BP)
  1674.     PEA    (PS)
  1675.     PEA    $14(DP)
  1676.     FX2DEC
  1677.     JSR    fdrop-base(BP)
  1678.     PEA    form-base(BP)
  1679.     PEA    $14(DP)
  1680.     MOVE.L    A2,-(RS)
  1681.     FDEC2STR
  1682.   dwrd:    JSR    here-base(BP)
  1683.     JSR    count-base(BP)
  1684.     JSR    type-base(BP)
  1685.     JMP    space-base(BP)
  1686.  
  1687.     DC.B    8,'FCO'        ; FCOMPARE ( f1 f2 -- f1 f2 [flag: -1|f1<f2 0|f1=f2 1|f1>f2] )
  1688.     DC.W    fdot-theLink
  1689. fcomp:    MOVE    #1,-(PS)
  1690.     PEA    2(PS)
  1691.     PEA    12(PS)
  1692.     FCMPX
  1693.     BGE.S    @0
  1694.     NEG    (PS)
  1695.     RTS
  1696.     @0:    BNE.S    @1
  1697.     CLR    (PS)
  1698.     @1:    RTS
  1699.  
  1700.     DC.B    2,'F+',0        ; F+ ( f1 f2 -- f1+f2 )
  1701.     DC.W    fcomp-theLink
  1702. fplus:    PEA    (PS)
  1703.     PEA    10(PS)
  1704.     FADDX
  1705.   fd1:    JMP    fdrop-base(BP)
  1706.  
  1707.     DC.B    2,'F-',0        ; F- ( f1 f2 -- f1-f2 )
  1708.     DC.W    fplus-theLink
  1709. fminus:    PEA    (PS)
  1710.     PEA    10(PS)
  1711.     FSUBX
  1712.     BRA.S    fd1
  1713.  
  1714.     DC.B    2,'F*',0        ; F* ( f1 f2 -- f1*f2 )
  1715.     DC.W    fminus-theLink
  1716. fstar:    PEA    (PS)
  1717.     PEA    10(PS)
  1718.     FMULX
  1719.     BRA.S    fd1
  1720.  
  1721.     DC.B    2,'F/',0        ; F/ ( f1 f2 -- f1/f2 )
  1722.     DC.W    fstar-theLink
  1723. fslash:    PEA    (PS)
  1724.     PEA    10(PS)
  1725.     FDIVX
  1726.     BRA.S    fd1
  1727.  
  1728.     DC.B    4,'FRE'            ; FREM ( f1 f2 -- rem[f1/f2] )
  1729.     DC.W    fslash-theLink
  1730. frem:    PEA    (PS)
  1731.     PEA    10(PS)
  1732.     FREMX
  1733.     BRA.S    fd1
  1734.  
  1735.     DC.B    2,'F^',0        ; F^ ( f1 f2 -- f1^f2 )
  1736.     DC.W    frem-theLink
  1737. ftothe:    PEA    (PS)
  1738.     PEA    10(PS)
  1739.     FXPWRY
  1740.     BRA.S    fd1
  1741.  
  1742.     DC.B    4,'FIN'            ; FINT ( f -- int[f] )
  1743.     DC.W    ftothe-theLink
  1744. finte:    PEA    (PS)
  1745.     FTINTX
  1746.     RTS
  1747.  
  1748.     DC.B    4,'FAB'            ; FABS ( f -- |f| )
  1749.     DC.W    finte -theLink
  1750. fabs:    PEA    (PS)
  1751.     FABSX
  1752.     RTS
  1753.  
  1754.     DC.B    5,'FSQ'            ; FSQRT ( f -- sqrt[f] )
  1755.     DC.W    fabs-theLink
  1756. fsqrt:    PEA    (PS)
  1757.     FSQRTX
  1758.     RTS
  1759.  
  1760.     DC.B    4,'FSI'            ; FSIN ( f -- sin[f] )
  1761.     DC.W    fsqrt-theLink
  1762. fsin:    PEA    (PS)
  1763.     FSINX
  1764.     RTS
  1765.  
  1766.     DC.B    4,'FCO'            ; FCOS ( f -- cos[f] )
  1767.     DC.W    fsin-theLink
  1768. fcos:    PEA    (PS)
  1769.     FCOSX
  1770.     RTS
  1771.  
  1772.     DC.B    4,'FTA'            ; FTAN ( f -- tan[f] )
  1773.     DC.W    fcos-theLink
  1774. ftan:    PEA    (PS)
  1775.     FTANX
  1776.     RTS
  1777.  
  1778.     DC.B    4,'FAT'            ; FATN ( f -- atn[f] )
  1779.     DC.W    ftan-theLink
  1780. fatn:    PEA    (PS)
  1781.     FATNX
  1782.     RTS
  1783.  
  1784.     DC.B    4,'FEX'            ; FEXP ( f1 -- e^f1 )
  1785.     DC.W    fatn-theLink
  1786. fexp:    PEA    (PS)
  1787.     FEXPX
  1788.     RTS
  1789.  
  1790.     DC.B    3,'FLN'            ; FLN ( f1 -- ln[f1] )
  1791.     DC.W    fexp-theLink
  1792. fln:    PEA    (PS)
  1793.     FLNX
  1794.     RTS
  1795.  
  1796.     DC.B    4,'@PE'            ; "@pen" ( -- h v )
  1797.     DC.W    fln-theLink
  1798. AtPen:    PEA    (DP)
  1799.     _GetPen
  1800.     MOVE.L    (DP),-(PS)
  1801.     RTS
  1802.  
  1803.     DC.B    64+4,'!PE'        ; "!pen" ( h v -- )
  1804.     DC.W    atpen-theLink
  1805. SetPen:    MOVE.L    (PS)+,-(SP)
  1806.     _MoveTo
  1807.     RTS
  1808.  
  1809.     DC.B    64+3,'-TO'        ; "-to" ( h v -- )
  1810.     DC.W    setpen-theLink
  1811. LineTo:    MOVE.L    (PS)+,-(SP)
  1812.     _LineTo
  1813.     RTS
  1814.  
  1815.     DC.B    64+5,'PMO'        ; "pmode" ( mode -- )
  1816.     DC.W    lineto-theLink
  1817. PMode:    MOVE    (PS)+,-(SP)
  1818.     _PenMode
  1819.     RTS
  1820.  
  1821.     DC.B    6,'@MO'            ; "@mouse" ( -- h v )
  1822.     DC.W    pmode-theLink
  1823. AtMouse:
  1824.     SUBQ.L    #4,PS
  1825.     PEA    (PS)
  1826.     _GetMouse
  1827.     RTS
  1828.  
  1829.     DC.B    4,'TAS'            ; "task" ( -- ) a no-op word
  1830.     DC.W    atmouse-theLink        ;  use:  forget task : task ;
  1831. Task:    RTS                ;  to cleanup dictionary
  1832. DictEnd:
  1833.